perm filename CHS.F4[1,VDS] blob
sn#124364 filedate 1974-10-09 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00027 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 C MAIN PROGRAM -- 'LOOK-UP'
C00016 00003 SUBROUTINE OUTPUT (SKIP)
C00024 00004 SUBROUTINE UPDATE
C00031 00005 SUBROUTINE MESAGE
C00034 00006 SUBROUTINE RESET
C00037 00007 SUBROUTINE CLEARS
C00040 00008 SUBROUTINE SETUP (*)
C00042 00009 SUBROUTINE CLEAR
C00045 00010 SUBROUTINE RPAREN
C00048 00011 SUBROUTINE EQUAL
C00050 00012 SUBROUTINE SEMI
C00053 00013 SUBROUTINE SIGN
C00056 00014 SUBROUTINE FUNCTN
C00059 00015 SUBROUTINE IMEDEX
C00061 00016 SUBROUTINE EXECUT (PTR, *)
C00065 00017 SUBROUTINE COMBIN (A, NARGS, OPER, *)
C00072 00018 SUBROUTINE CLEARX
C00075 00019 SUBROUTINE ENTRY
C00079 00020 SUBROUTINE DIGIT
C00082 00021 SUBROUTINE DECPT
C00085 00022 SUBROUTINE CORECT
C00089 00023 SUBROUTINE RECALL
C00092 00024 SUBROUTINE STORE
C00096 00025 SUBROUTINE REG (RN)
C00099 00026 SUBROUTINE FINDN (K, RN, START)
C00102 00027 SUBROUTINE FIXN
C00110 ENDMK
C⊗;
C MAIN PROGRAM -- 'LOOK-UP'
C DATE OF LAST CHANGE - 740814
IMPLICIT INTEGER (A-Z)
LOGICAL START, NEXT, FIXFLG, TRUE
COMMON /STACK/ P(6), X(6,17), OP(6), D(16)
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ CODE, EXPR(50), KEY, OLD
* /MISC/ L, M, FIX, SCI, ERROR, R(21,17), W(17)
10 DO 20 I=2,21
DO 20 J=1,17
R(I,J)=0
20 R(I,2)=15
R(21,1)=15
R(21,2)=1
R(21,3)=5
R(21,17)=1
C REGISTERS ARE ALLOCATED AS FOLLOWS: R(1)="PI", R(2)="A",
C R(3)="LST X", R(4)="LST Y", R(5)="R0", ..., R(20)="R15",
C R(21)="HIGHEST REG NO. AVAILABLE"
C ** CONTROL PARAMETERS
C SIZE = NO. OF KEYS ON KEYBOARD (SEE DECODER BELOW)
C SWITCH = OUTPUT CONTROL (0 -> NORMAL, 1 -> SHORT, 2 -> DISPLAY)
C FIXFLG = "DISPLAY" CONTROL (T = "FIX" MODE)
C FIX = NUMBER OF DECIMAL DIGITS IN "FIX" MODE (0-9)
C SCI = NUMBER OF DIGITS IN "SCI" MODE (0-9)
C
SIZE=48
SWITCH=1
FIXFLG=.TRUE.
FIX=2
SCI=5
C
TYPE 1000
ACCEPT 1005, START
IF (START) GO TO 30
TYPE 1001
ACCEPT 1006, SWITCH
TYPE 1002
ACCEPT 1005, START
IF (START) GO TO 30
TYPE 1003
ACCEPT 1005, FIXFLG
TYPE 1004
ACCEPT 1007, FIX, SCI
SCI=SCI+1
C CONSIDER 100 TEST EQUATIONS
30 DO 270 TEST=1,100
ERROR=0
OLD=1
DO 40 I=1,50
40 EXPR(I)=15
CALL CLEAR
TYPE 1008, TEST
CALL OUTPUT (-1)
KEY=0
C OUTPUT CURRENT INFO & OBTAIN NEXT KEY-CODE
50 CALL CONTRL (SWITCH)
C DECODE KEY-CODE
IF (NEXT) NEXT=.FALSE.
IF (CODE.GT.SIZE) GO TO 60
IF (CODE.LE.12) GO TO 70
IF (CODE.EQ.13 .OR. CODE.EQ.14) GO TO 80
IF (CODE.GT.15.AND.CODE.LT.20.AND.CODE.NE.18) GO TO 90
IF (CODE.EQ.18) GO TO 100
IF (CODE.EQ.20) GO TO 110
IF (CODE.EQ.22) GO TO 130
IF (CODE.GT.22 .AND. CODE.LT.26 .OR.
* CODE.EQ.38 .OR. CODE.EQ.39) GO TO 140
IF (CODE.EQ.26) GO TO 150
IF (CODE.EQ.27) GO TO 160
IF (CODE.EQ.28) GO TO 170
IF (CODE.EQ.31) GO TO 180
IF (CODE.EQ.32) GO TO 190
IF (CODE.EQ.33) GO TO 200
IF (CODE.EQ.34) GO TO 210
IF (CODE.EQ.35) GO TO 220
IF (CODE.EQ.36) GO TO 230
IF (CODE.EQ.37) GO TO 240
IF (CODE.GT.39 .AND. CODE.LT.44) GO TO 90
IF (CODE.GT.43 .AND. CODE.LT.49) GO TO 120
IF (CODE.EQ.15.OR.CODE.EQ.29.OR.CODE.EQ.30) GO TO 260
C KEY-CODE ERROR?
60 IF (CODE.EQ.99) GO TO 10
ERROR=98
GO TO 250
C CALL KEY ROUTINE
70 CALL ENTRY
GO TO 250
80 CALL SIGN
GO TO 250
90 CALL OPRATR
GO TO 250
100 CALL LPAREN
GO TO 250
110 CALL RPAREN
GO TO 250
120 CALL FUNCTN
GO TO 250
130 CALL EQUAL
GO TO 250
140 CALL RECALL
GO TO 250
150 CALL CLEAR
GO TO 270
160 CALL CLEARX
GO TO 250
170 CALL CORECT
GO TO 250
180 CALL STORE
GO TO 250
190 CALL FIXN
GO TO 250
200 CALL SCIN
GO TO 250
210 CALL IMEDEX
GO TO 250
220 CALL EXCH
GO TO 250
230 CALL SEMI
GO TO 250
240 CALL COMMA
C GO BACK AND GET ANOTHER KEY-STROKE, MAYBE
250 IF (ERROR.NE.0) CALL MESAGE
260 IF (KEY.LT.50) GO TO 50
270 CONTINUE
STOP
1000 FORMAT (///' THE STANDARD CONTROL SETTINGS ARE:'
* /' PRODUCE "SHORT STACK" OUTPUT'
* /' DISPLAY IN FIX MODE W/ FIX=2 & SCI=5'
* //' THESE ARE OKAY. (T OR F)'/)
1001 FORMAT (/' ENTER CODE FOR DESIRED OUTPUT: 0 = LONG'/32X,
* ' 1 = SHORT'/33X,'2 = DISPLAY ONLY'/)
1002 FORMAT (/' THE STANDARD DISPLAY SETTINGS ARE WANTED.',
* ' (T OR F)'/)
1003 FORMAT (/' FIX MODE DISPLAY IS WANTED INITIALLY. (T OR F)'/)
1004 FORMAT (/' ENTER NUMBER OF DECIMAL DIGITS DESIRED IN FIX'
* /' AND SCI MODES, RESPECTIVELY. (N <SP> M)'/)
1005 FORMAT (L1)
1006 FORMAT (I)
1007 FORMAT (2I)
1008 FORMAT ('1 TEST NO.',I3/)
END
C
C
C
C
C
C
C
C
C
C
BLOCK DATA
C DATE OF LAST CHANGE - 740310
IMPLICIT INTEGER (A-Z)
LOGICAL JUMP, NEXT
COMMON /STACK/ P(6), X(6,17), OP(6), D(16)
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /MISC/ L, M, FIX, SCI, ERROR, R(21,17), W(17)
DATA P /6*0/, OP /6*0/, D /16*13/, X /102*13/,
* JUMP, NEXT /2*.FALSE./,
* R(1,1),R(1,2),R(1,3),R(1,4),R(1,5),R(1,6),R(1,7),R(1,8),
* R(1,9),R(1,10),R(1,11),R(1,12),R(1,13),R(1,14),R(1,15),
* R(1,16),R(1,17) /15,3,1,4,1,5,9,2,6,5,3,5,9,0,15,0,0/
END
SUBROUTINE OUTPUT (SKIP)
C DATE OF LAST CHANGE - 740814
IMPLICIT INTEGER (A-Z)
INTEGER*2 CHAR(48), STROKE(50), SIGN(6), ESN(6),
* DISPLY(16), REG(17)
LOGICAL EEX, DP, FIXFLG, MVO, SUM
REAL*8 NAME(3)
COMMON /STACK/ P(6), X(6,17), OP(6), D(16)
2 /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
3 /INPUTS/ CODE, EXPR(50), KEY, OLD
* /MISC/ L, M, FIX, SCI, ERROR, R(21,17), W(17)
DATA CHAR( 1),CHAR( 2),CHAR( 3),CHAR( 4)/' 1',' 2',' 3',' 4'/,
2 CHAR( 5),CHAR( 6),CHAR( 7),CHAR( 8)/' 5',' 6',' 7',' 8'/,
3 CHAR( 9),CHAR(10),CHAR(11),CHAR(12)/' 9',' 0',' .','EE'/,
4 CHAR(13),CHAR(14),CHAR(15),CHAR(16)/' -',' +',' ',' /'/,
5 CHAR(17),CHAR(18),CHAR(19),CHAR(20)/' *',' (','**',' )'/,
6 CHAR(21),CHAR(22),CHAR(23),CHAR(24)/' O',' =',' A','PI'/,
7 CHAR(25),CHAR(26),CHAR(27),CHAR(28)/' R','CL','CX','CO'/,
8 CHAR(29),CHAR(30),CHAR(31),CHAR(32)/' E','SV','->','FX'/,
9 CHAR(33),CHAR(34),CHAR(35),CHAR(36)/'SN','IX','XC',' ;'/,
A CHAR(37),CHAR(38),CHAR(39),CHAR(40)/' ,','LX','LY',' ='/,
B CHAR(41),CHAR(42),CHAR(43),CHAR(44)/' #',' >',' <','MG'/,
C CHAR(45),CHAR(46),CHAR(47),CHAR(48)/'AG','AB','SR','↑2'/
DATA NAME /' A =', 'LAST X =','LAST Y ='/
C VARIOUS VALUES OF 'SKIP' GIVE: -1 → CLEAR EXPRESSION
C 0 → LONG OUTPUT
C 1 → SHORT OUTPUT
C 2 → DISPLAY ONLY
IF (SKIP.GE.0) GO TO 20
DO 10 I=1,50
10 STROKE(I)=CHAR(15)
RETURN
20 DO 30 I=OLD,KEY
J=EXPR(I)
IF (J.EQ.0) J=10
30 STROKE(I)=CHAR(J)
TYPE 1000, (STROKE(I),I=1,KEY)
OLD=KEY+1
IF (SKIP.EQ.2) GO TO 70
DO 60 I=1,6
J=X(I,1)
IF (J.EQ.0) J=15
SIGN(I)=CHAR(J)
K=X(I,15)
IF (K.EQ.0) K=15
60 ESN(I)=CHAR(K)
70 DO 80 I=1,16
J=D(I)
IF (J.EQ.0) J=10
80 DISPLY(I)=CHAR(J)
IF (SKIP.EQ.2) GO TO 100
IF (SKIP.EQ.1) GO TO 90
TYPE 2000, DP, L, EEX, M, FIXFLG, FIX, MVO, SCI, SUM, ERROR
TYPE 3000, P(6),SIGN(6),(X(6,N),N=2,14),ESN(6),X(6,16),
2 X(6,17),OP(6),P(5),SIGN(5),(X(5,N),N=2,14),
3 ESN(5),X(5,16),X(5,17),OP(5),P(4),SIGN(4),
4 (X(4,N),N=2,14),ESN(4),X(4,16),X(4,17),OP(4),
5 P(3),SIGN(3),(X(3,N),N=2,14),ESN(3),X(3,16),
6 X(3,17),OP(3)
90 TYPE 4000, P(2),SIGN(2),(X(2,N),N=2,14),ESN(2),X(2,16),
2 X(2,17),OP(2),P(1),SIGN(1),(X(1,N),N=2,14),
3 ESN(1),X(1,16),X(1,17),OP(1)
100 TYPE 5000, DISPLY
IF (SKIP.EQ.2) RETURN
DO 120 I=2,4
IF (R(I,2).EQ.15) GO TO 120
DO 110 J=1,17
K=R(I,J)
IF (K.EQ.0) K=10
110 REG(J)=CHAR(K)
TYPE 6000, NAME(I-1), (REG(N), N=1,17)
120 CONTINUE
DO 140 I=5,20
IF (R(I,2).EQ.15) GO TO 140
J=I-5
DO 130 K=1,17
KK=R(I,K)
IF (KK.EQ.0) KK=10
130 REG(K)=CHAR(KK)
TYPE 7000, J, (REG(N), N=1,17)
140 CONTINUE
RETURN
1000 FORMAT (/6X,'EXPRESSION: ',39A3/30X,11A3)
2000 FORMAT (//14X,'FLAGS: DP -',L2,20X,'INDICES: L -',
2 I2/22X,'EEX -',L2,30X,'M -',I2/22X,
3 'FIXFLG-',L2,30X,'FIX -',I2/22X,'MVO -',L2,30X,
4 'SCI -',I2/22X,'SUM -',L2,30X,'ERROR -',I2)
3000 FORMAT (//14X,'STACK: S(6) -',4X,I2,' / ',A2,I2,' .',12I2,
2 A2,2I2,' /',I3/22X,'S(5) -',4X,I2,' / ',A2,I2,' .',
3 12I2,A2,2I2,' /',I3/22X,'S(4) -',4X,I2,' / ',A2,I2,
4 ' .',12I2,A2,2I2,' /',I3/22X,'S(3) -',4X,I2,' / ',
5 A2,I2,' .',12I2,A2,2I2,' /',I3)
4000 FORMAT (/22X,'S(2) -',4X,I2,' / ',A2,I2,' .',12I2,A2,2I2,' /',
2 I3/22X,'S(1) -',4X,I2,' / ',A2,I2,' .',12I2,A2,2I2,
3 ' /',I3/)
5000 FORMAT (/14X,'DISPLAY:',9X,16A3///)
6000 FORMAT (15X,A8,1X,2A3,' .',15A3)
7000 FORMAT (14X,'REG(',I2,') =',1X,2A3,' .',15A3)
END
SUBROUTINE UPDATE
C DATE OF LAST CHANGE - 740920
IMPLICIT INTEGER (A-Z)
LOGICAL FIXFLG
COMMON /STACK/ P(6), X(6,17), OP(6), D(16)
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /MISC/ L, M, FIX, SCI, ERROR, R(21,17), W(17)
D(1)=X(1,1)
IF (D(1).EQ.14) D(1)=15
IF (OP(1).GT.60) D(1)=15
IF (.NOT.FIXFLG) GO TO 15
C DISPLAY IN "FIX" FORMAT
IF (X(1,16).GT.0) GO TO 15
IF (X(1,15).EQ.13) GO TO 5
N=X(1,17)+FIX+1
IF (N.GT.10) GO TO 15
CALL ROUND (N)
K=W(17)+2
DO 2 I=2,K
2 D(I)=W(I)
K=K+1
D(K)=11
IF (FIX.EQ.0) GO TO 4
DO 3 I=1,FIX
3 D(I+K)=W(I+K-1)
4 K=N+3
GO TO 13
5 D(2)=10
D(3)=11
K=FIX-X(1,17)+1
IF (K.LE.0) GO TO 8
CALL ROUND (K)
J=W(17)+2
DO 6 I=4,J
6 D(I)=10
DO 7 I=1,K
7 D(J+I)=W(I+1)
GO TO 12
8 IF (K.NE.0) GO TO 9
N=1
CALL ROUND (N)
IF (N.EQ.1) GO TO 9
D(FIX+3)=1
J=FIX+2
GO TO 10
9 J=FIX+3
10 DO 11 I=4,J
11 D(I)=10
12 K=FIX+4
13 DO 14 I=13,16
14 D(I)=15
GO TO 18
C DISPLAY IN "SCI" FORMAT
15 N=SCI
CALL ROUND (N)
D(13)=29
DO 16 I=14,16
16 D(I)=W(I+1)
D(2)=W(2)
D(3)=11
K=SCI+3
DO 17 I=5,K
17 D(I-1)=W(I-2)
18 DO 19 I=K,12
19 D(I)=15
RETURN
END
C
C
C
C
C
C
C
C
C
C
SUBROUTINE ROUND (N)
C DATE OF LAST CHANGE - 740920
C PURPOSE: ROUND X(1,I) TO N DIGITS & PUT RESULT IN W(I)
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(6), X(6,17), OP(6), D(16)
* /MISC/ L, M, FIX, SCI, ERROR, R(21,17), W(17)
DO 1 I=1,17
1 W(I)=X(1,I)
IF (W(2).GE.15) W(2)=0
IF (OP(1).GT.60) W(2)=0
IF (W(N+2)-5) 9,2,4
2 K=N+3
DO 3 I=K,14
IF (W(I).GT.0) GO TO 4
3 CONTINUE
K=N+1
IF (2*(W(K)/2) .EQ. W(K)) GO TO 9
4 K=N+1
W(K)=W(K)+1
5 IF (W(K).LT.10) GO TO 9
W(K)=W(K)-10
IF (K.EQ.2) GO TO 6
K=K-1
W(K)=W(K)+1
GO TO 5
6 K=N+1
7 W(K+1)=W(K)
IF (K.EQ.2) GO TO 8
K=K-1
GO TO 7
8 W(2)=1
N=N+1
CALL EXPON (W(15), W(16), W(17), 1)
9 RETURN
END
SUBROUTINE MESAGE
C DATE OF LAST CHANGE - 740930
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT
COMMON /STACK/ P(6), X(6,17), OP(6), D(16)
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ CODE, EXPR(50), KEY, OLD
* /MISC/ L, M, FIX, SCI, ERROR, R(21,17), W(17)
NEXT=.FALSE.
DO 1 I=1,16
1 D(I)=13
D(5)=29
D(6)=25
D(7)=25
D(8)=21
D(9)=25
D(10)=15
D(11)=ERROR/10
D(12)=ERROR-10*D(11)
IF (ERROR.NE.17) GO TO 2
D(15)=CODE/10
D(16)=CODE-10*D(15)
2 CALL CONTRL (2)
IF (CODE.EQ.26) GO TO 3
IF (CODE.NE.27) GO TO 2
CALL UPDATE
GO TO 4
3 CALL CLEAR
4 ERROR=0
RETURN
END
C
C
C
C
SUBROUTINE CONTRL (PRINT)
C DATE OF LAST CHANGE - 740704
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT
COMMON /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ CODE, EXPR(50), KEY, OLD
CALL OUTPUT (PRINT)
IF (NEXT) RETURN
1 TYPE 3
ACCEPT 4, CODE
IF (CODE.NE.100) GO TO 2
CALL OUTPUT (0)
GO TO 1
2 KEY=KEY+1
EXPR(KEY)=CODE
IF (CODE.EQ.10) CODE=0
RETURN
3 FORMAT (' ?'/)
4 FORMAT (I)
END
SUBROUTINE RESET
C DATE OF LAST CHANGE - 740210
IMPLICIT INTEGER (A-Z)
LOGICAL EEX, DP
COMMON /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /MISC/ L, M, FIX, SCI, ERROR, R(21,17), W(17)
L=1
M=1
DP=.FALSE.
EEX=.FALSE.
CALL UPDATE
RETURN
END
C
C
C
C
C
C
C
C
C
SUBROUTINE TESTUP (*)
C DATE OF LAST CHANGE - 740625
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(6), X(6,17), OP(6), D(16)
* /MISC/ L, M, FIX, SCI, ERROR, R(21,17), W(17)
IF (X(6,2).EQ.15) RETURN
IF (OP(2).LT.50) GO TO 1
IF (P(1).EQ.0) RETURN
1 ERROR=8
RETURN 1
END
C
C
C
C
C
C
C
C
C
SUBROUTINE ENTRUP
C DATE OF LAST CHANGE - 740630
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(6), X(6,17), OP(6), D(16)
DO 1 I=1,5
J=6-I
K=J+1
P(K)=P(J)
OP(K)=OP(J)
DO 1 L=1,17
1 X(K,L)=X(J,L)
CALL CLEARS
RETURN
END
SUBROUTINE CLEARS
C DATE OF LAST CHANGE - 740310
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(6), X(6,17), OP(6), D(16)
P(1)=0
CALL CLEARX
RETURN
END
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
SUBROUTINE DROP (START)
C DATE OF LAST CHANGE - 740904
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(6), X(6,17), OP(6), D(16)
IF (START.EQ.2) GO TO 1
C ** START 1 - DROP S(2), ..., S(6)
J=1
GO TO 2
C ** START 2 - DROP S(3), ..., S(6)
1 P(1)=P(2)
J=2
2 DO 3 I=J,5
JJ=I+1
P(I)=P(JJ)
OP(I)=OP(JJ)
DO 3 K=1,17
3 X(I,K)=X(JJ,K)
IF (OP(6).EQ.0) RETURN
OP(6)=0
P(6)=0
DO 4 I=1,17
4 X(6,I)=0
X(6,2)=15
5 RETURN
END
SUBROUTINE SETUP (*)
C DATE OF LAST CHANGE - 740806
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(6), X(6,17), OP(6), D(16)
* /MISC/ L, M, FIX, SCI, ERROR, R(21,17), W(17)
IF (X(1,2).EQ.15) RETURN
IF (OP(1).NE.0) GO TO 2
CALL TESTUP (&3)
OP(1)=50
CALL COLAPS (&3)
1 CALL ENTRUP
RETURN
2 IF (OP(1).EQ.1) GO TO 4
IF (X(6,2).EQ.15) GO TO 1
ERROR=8
3 RETURN 1
4 DO 5 I=1,17
5 R(3,I)=X(1,I)
CALL CLEARX
RETURN
END
SUBROUTINE CLEAR
C DATE OF LAST CHANGE - 740920
IMPLICIT INTEGER (A-Z)
LOGICAL MVO, SUM
COMMON /STACK/ P(6), X(6,17), OP(6), D(16)
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
CALL CLEARS
DO 1 I=2,6
J=I-1
P(I)=P(J)
OP(I)=OP(J)
DO 1 K=1,17
1 X(I,K)=X(J,K)
MVO=.FALSE.
SUM=.FALSE.
RETURN
END
C
C
C
C
C
C
C
C
C
C
SUBROUTINE LPAREN
C DATE OF LAST CHANGE - 740715
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(6), X(6,17), OP(6), D(16)
* /MISC/ L, M, FIX, SCI, ERROR, R(21,17), W(17)
IF (P(1).NE.4) GO TO 1
ERROR=8
RETURN
1 IF (X(1,2).NE.15) GO TO 2
IF (X(1,1).NE.13) GO TO 8
CALL TESTUP (&9)
X(1,2)=1
GO TO 3
2 IF (OP(1).NE.0) GO TO 4
CALL TESTUP (&9)
3 OP(1)=50
CALL COLAPS (&9)
GO TO 7
4 IF (OP(1).NE.1) GO TO 6
DO 5 I=1,17
5 R(3,I)=X(1,I)
CALL CLEARX
GO TO 8
6 IF (X(6,2).EQ.15) GO TO 7
ERROR=8
RETURN
7 CALL ENTRUP
8 P(1)=P(1)+1
9 RETURN
END
SUBROUTINE RPAREN
C DATE OF LAST CHANGE - 740806
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(6), X(6,17), OP(6), D(16)
* /MISC/ L, M, FIX, SCI, ERROR, R(21,17), W(17)
IF (OP(1).LT.2) GO TO 2
1 ERROR=1
RETURN
2 DO 3 I=1,6
IF (P(I).NE.0) GO TO 4
3 CONTINUE
ERROR=2
RETURN
4 IF (OP(I+1).NE.71) GO TO 5
IF (I.EQ.1) GO TO 1
IF (P(I).NE.1) GO TO 5
IF (OP(I).NE.10) GO TO 1
5 IF (P(1).NE.0) GO TO 8
IF (X(1,2).EQ.15) GO TO 1
IF (OP(2).NE.10) GO TO 7
DO 6 I=3,6
IF (OP(I).NE.71) GO TO 6
PTR=I
GO TO 12
6 CONTINUE
GO TO 1
7 CALL EXECUT (2, &14)
GO TO 4
8 P(1)=P(1)-1
IF (P(1).NE.0) GO TO 13
IF (X(1,2).NE.15) GO TO 11
IF (OP(2).NE.50) GO TO 13
C HERE TO STATEMENT 11 FIXES UP "-()"
OP(2)=0
IF (X(2,2).NE.1) GO TO 10
DO 9 I=3,14
IF (X(2,I).NE.0) GO TO 10
9 CONTINUE
IF (X(2,16).NE.0) GO TO 10
IF (X(2,17).NE.0) GO TO 10
X(2,2)=15
10 CALL DROP(1)
GO TO 13
11 IF (OP(2).NE.70) GO TO 13
PTR=2
12 CALL EXECUT (PTR, &14)
RETURN
13 CALL UPDATE
14 RETURN
END
SUBROUTINE EQUAL
C DATE OF LAST CHANGE - 740614
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(6), X(6,17), OP(6), D(16)
* /MISC/ L, M, FIX, SCI, ERROR, R(21,17), W(17)
IF (OP(1).LT.10) GO TO 1
ERROR=1
RETURN
1 DO 2 I=1,6
IF (P(I).EQ.0) GO TO 2
ERROR=2
RETURN
2 CONTINUE
3 IF (OP(2).EQ.0) GO TO 4
CALL EXECUT (2, &5)
GO TO 3
4 OP(1)=1
CALL UPDATE
5 RETURN
END
C
C
C
C
C
C
C
C
C
C
SUBROUTINE EXCH
C DATE OF LAST CHANGE - 740620
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(6), X(6,17), OP(6), D(16)
DO 1 I=1,17
W=X(1,I)
X(1,I)=X(2,I)
1 X(2,I)=W
CALL UPDATE
RETURN
END
SUBROUTINE SEMI
C DATE OF LAST CHANGE - 741004
IMPLICIT INTEGER (A-Z)
LOGICAL SUM, IF
COMMON /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
DATA IF /.FALSE./
IF (.NOT.SUM) GO TO 1
C TREAT AS ARGUMENT SEPARATOR FOR "SIGMA"
C- CALL SIGMA (3)
RETURN
1 IF (.NOT.IF) GO TO 2
C TREAT AS STRING SEPARATOR FOR "IF"
C- CALL IF (2)
C- RETURN
C TREAT AS GENERAL ARGUMENT SEPARATOR
2 CALL OPRATR
RETURN
END
C
C
C
C
C
C
C
C
C
C
C
C
SUBROUTINE COMMA
C DATE OF LAST CHANGE - 741004
IMPLICIT INTEGER (A-Z)
LOGICAL MVO, SUM
COMMON /STACK/ P(6), X(6,17), OP(6), D(16)
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /MISC/ L, M, FIX, SCI, ERROR, R(21,17), W(17)
IF (.NOT.MVO) GO TO 3
C TREAT AS ARGUMENT SEPARATOR FOR "MVO"
DO 1 I=2,6
IF (OP(I).NE.71) GO TO 1
IF (P(I-1).EQ.1) GO TO 2
ERROR=2
RETURN
1 CONTINUE
ERROR=1
RETURN
2 CALL OPRATR
RETURN
3 IF (.NOT.SUM) RETURN
C TREAT AS ARGUMENT SEPARATOR FOR "SIGMA"
C- IF (SUM) CALL SIGMA (2)
RETURN
END
SUBROUTINE SIGN
C DATE OF LAST CHANGE - 740715
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(6), X(6,17), OP(6), D(16)
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ CODE, EXPR(50), KEY, OLD
* /MISC/ L, M, FIX, SCI, ERROR, R(21,17), W(17)
IF (OP(1).NE.0) GO TO 2
IF (X(1,2).EQ.15) GO TO 4
1 OP(1)=CODE+17
CALL COLAPS (&5)
RETURN
2 IF (OP(1).EQ.1) GO TO 1
IF (X(6,2).EQ.15) GO TO 3
ERROR=8
RETURN
3 CALL ENTRUP
4 IF (CODE.NE.13) RETURN
IF (X(1,1).EQ.13) D(1)=15
IF (X(1,1).NE.13) D(1)=13
X(1,1)=D(1)
5 RETURN
END
C
C
C
C
C
C
C
C
C
C
SUBROUTINE OPRATR
C DATE OF LAST CHANGE - 740925
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(6), X(6,17), OP(6), D(16)
* /INPUTS/ CODE, EXPR(50), KEY, OLD
* /MISC/ L, M, FIX, SCI, ERROR, R(21,17), W(17)
IF (OP(1).LT.2) GO TO 1
ERROR=1
RETURN
1 IF (X(1,2).EQ.15) X(1,2)=0
IF (CODE.LT.19) OP(1)=CODE+24
IF (CODE.EQ.19) OP(1)=60
IF (CODE.EQ.36) OP(1)=10
IF (CODE.EQ.37) OP(1)=10
IF (CODE.GT.37) OP(1)=CODE-20
CALL COLAPS (&2)
2 RETURN
END
SUBROUTINE FUNCTN
C DATE OF LAST CHANGE - 740923
IMPLICIT INTEGER (A-Z)
LOGICAL MVO, NEXT
COMMON /STACK/ P(6), X(6,17), OP(6), D(16)
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ CODE, EXPR(50), KEY, OLD
* /MISC/ L, M, FIX, SCI, ERROR, R(21,17), W(17)
IF (CODE.EQ.48) GO TO 4
C ** START 1 - MULTIPLE VARIABLE FUNCTION
IF (CODE.EQ.44 .OR. CODE.EQ.45) MVO=.TRUE.
C ** START 2 - SINGLE VARIABLE FUNCTION
CALL SETUP (&6)
X(1,2)=CODE
D(1)=15
IF (MVO) GO TO 1
OP(1)=70
RETURN
1 OP(1)=71
2 CALL CONTRL (1)
IF (CODE.EQ.18) GO TO 3
IF (CODE.EQ.26) GO TO 3
IF (CODE.EQ.27) GO TO 3
ERROR=1
CALL MESAGE
IF (CODE.EQ.26) GO TO 3
GO TO 2
3 NEXT=.TRUE.
RETURN
C ** START 3 - "IMMEDIATE" SINGLE VARIABLE FUNCTION
4 IF (OP(1).LT.2) GO TO 5
ERROR=1
RETURN
5 OP(1)=70
CALL COLAPS (&6)
OP(1)=0
PTR=0
CALL EXECUT (PTR, &6)
6 RETURN
END
SUBROUTINE IMEDEX
C DATE OF LAST CHANGE - 740925
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(6), X(6,17), OP(6), D(16)
* /MISC/ L, M, FIX, SCI, ERROR, R(21,17), W(17)
IF (OP(1).LT.2) GO TO 1
IF (OP(1).EQ.71) GO TO 1
IF (X(1,2).EQ.15) GO TO 1
IF (OP(2).LT.20 .OR. OP(2).EQ.50) GO TO 2
1 ERROR=1
RETURN
2 IF (X(2,2).EQ.15) X(2,2)=0
OP(2)=OP(1)
OP(1)=0
PTR=2
IF (OP(2).EQ.70) CALL EXCH
CALL EXECUT (PTR, &3)
3 RETURN
END
C
C
C
C
C
C
C
C
C
C
C
C
C
SUBROUTINE COLAPS (*)
C DATE OF LAST CHANGE - 740809
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(6), X(6,17), OP(6), D(16)
1 IF (P(1).NE.0) RETURN
IF (OP(2).EQ.10) RETURN
IF (OP(1)/10 .GT. OP(2)/10) RETURN
PTR=2
CALL EXECUT (PTR, &2)
GO TO 1
2 RETURN 1
END
SUBROUTINE EXECUT (PTR, *)
C DATE OF LAST CHANGE - 740920
IMPLICIT INTEGER (A-Z)
LOGICAL MVO
DIMENSION A(2,17)
COMMON /STACK/ P(6), X(6,17), OP(6), D(16)
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ CODE, EXPR(50), KEY, OLD
* /MISC/ L, M, FIX, SCI, ERROR, R(21,17), W(17)
DATA A/34*0/
IF (OP(2).EQ.70 .OR. PTR.EQ.0) GO TO 5
C ** START 1 - BINARY OPERATORS & MULTIPLE ARGUMENT FUNCTIONS
C SAVE X(2,N) IN "LST X" & X(1,N) IN "LST Y"
DO 1 I=1,2
DO 1 N=1,17
R(5-I,N)=X(I,N)
1 A(I,N)=X(I,N)
IF (OP(PTR).EQ.71) GO TO 3
C EXECUTE BINARY FUNCTION
CALL COMBIN (A, 2, OP(2), &13)
DO 2 N=1,17
2 X(1,N)=A(1,N)
GO TO 11
C EXECUTE "MVO"
3 OPER=OP(PTR)+X(PTR,2)
CALL COMBIN (A, 2, OPER, &13)
J=PTR+1
DO 4 I=J,6
IF (OP(I).EQ.71) GO TO 9
4 CONTINUE
MVO=.FALSE.
GO TO 9
C ** START 2 - SINGLE ARGUMENT FUNCTIONS
C SAVE X(1,N) IN "LST X"; EXECUTE "SVO"
5 DO 6 N=1,17
R(3,N)=X(1,N)
6 A(1,N)=X(1,N)
IF (PTR.NE.0) GO TO 7
OPER=70+CODE
GO TO 8
7 OPER=OP(2)+X(2,2)
8 CALL COMBIN (A, 1, OPER, &13)
9 DO 10 N=1,17
10 X(1,N)=A(1,N)
IF (PTR.EQ.0) GO TO 12
C CONSIDER SIGN PRECEEDING FUNCTION
IF (X(PTR,1).NE.13) GO TO 11
SIGN=X(1,1)
IF (SIGN.EQ.13) X(1,1)=14
IF (SIGN.NE.13) X(1,1)=13
C DROP STACK APPROPRIATE AMOUNT
11 CALL DROP(2)
IF (PTR.LT.3) GO TO 12
PTR=PTR-1
GO TO 11
12 CALL UPDATE
RETURN
13 RETURN 1
END
SUBROUTINE COMBIN (A, NARGS, OPER, *)
C DATE OF LAST CHANGE - 740814
C PURPOSE: EXECUTE- "A(2,N) OPER A(1,N) → A(1,N)"
C "SVO [A(1,N)] → A(1,N)"
C "[A(2,N)] SVO → A(1,N)"
C "MVO [A(2,N); A(1,N)] → A(1,N)"
IMPLICIT INTEGER (A-Z)
REAL*8 RX(2), RX1, DLOG10, DABS, DLOG, DEXP, DSQRT, E
DIMENSION A(2,17)
COMMON /MISC/ L, M, FIX, SCI, ERROR, R(21,17), W(17)
C CONVERT A(I,N) TO RX(I)
DO 2 I=1,2
RX(I)=A(I,14)
DO 1 J=1,12
K=14-J
1 RX(I)=0.1*RX(I)+A(I,K)
IF (A(I,1).EQ.13) RX(I)=-RX(I)
J=10*A(I,16)+A(I,17)
IF (J.GT.20) J=20
IF (A(I,15).EQ.13) J=-J
2 RX(I)=RX(I)*10.0**J
RX1=RX(1)
IF (OPER.GT.60) GO TO 14
C NOW EXECUTE RX(2), OPER, RX(1) -> RX(1)=RX1
IF (OPER.GT.31) GO TO 3
IF (OPER.LT.30) GO TO 8
C ADDITION/SUBTRACTION
IF (OPER.EQ.30) RX1=-RX1
RX1=RX(2)+RX1
GO TO 22
3 IF (OPER.GT.50) GO TO 7
IF (OPER.EQ.40) GO TO 4
C MULTIPLICATION/DIVISION
RX1=RX(2)*RX1
GO TO 22
4 IF (RX1.GT.1.0E-20) GO TO 6
5 ERROR=6
RETURN 1
6 RX1=RX(2)/RX1
GO TO 22
C EXPONENTIATION
7 IF (RX(2).LE.0.0) GO TO 5
RX1=RX1*DLOG(RX(2))
IF (DABS(RX1).GT.85.) ERROR=7
IF (DABS(RX1).GT.85.) RX1=85.*RX1/DABS(RX1)
RX1=DEXP(RX1)
GO TO 22
C RELATIONALS
8 VALUE=0
GO TO (9, 10, 11, 12), OPER-19
9 IF (RX(2) .EQ. RX1) VALUE=1
GO TO 13
10 IF (RX(2) .NE. RX1) VALUE=1
GO TO 13
11 IF (RX(2) .GT. RX1) VALUE=1
GO TO 13
12 IF (RX(2) .LT. RX1) VALUE=1
13 RX1=VALUE
GO TO 22
C EXECUTE SPECIAL FUNCTIONS
14 IF (NARGS.NE.1) GO TO 18
C SINGLE VARIABLE FUNCTIONS
GO TO (15, 16, 17), OPER-115
15 RX1=DABS(RX1)
GO TO 22
16 RX1=DSQRT(RX1)
GO TO 22
17 RX1=RX1*RX1
GO TO 22
C MULTIPLE VARIABLE FUNCTIONS
18 GO TO (19, 20), OPER-114
19 RX1=DSQRT(RX1*RX1+RX(2)*RX(2))
GO TO 22
20 IF (DABS(RX(2)).GT.1.E-20) GO TO 21
ERROR=6
RETURN 1
21 RX1=DATAN(RX1/RX(2))*57.29577951D0
C EXTRACT EXPONENT, -> A(1,15), ..., A(1,17)
22 IF (RX1.EQ.0.) GO TO 23
E=DLOG10(DABS(RX1))+.00001
GO TO 24
23 K=0
GO TO 26
24 IF (E.GE.0.0) GO TO 25
K=-E+1
RX1=RX1*10.0**K
A(1,15)=13
GO TO 27
25 K=E
RX1=RX1/10.0**K
26 A(1,15)=14
27 A(1,16)=K/10
A(1,17)=K-10*A(1,16)
C CONVERT RX1=RX(1) TO A(1,N), N=1, ..., 14
IF (RX1.GE.0.0) GO TO 28
A(1,1)=13
RX1=-RX1
GO TO 29
28 A(1,1)=14
29 A(1,2)=RX1
DO 30 I=3,14
J=I-1
RX1=10.*(RX1-A(1,J))
30 A(1,I)=RX1
RETURN
END
SUBROUTINE CLEARX
C DATE OF LAST CHANGE - 740616
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(6), X(6,17), OP(6), D(16)
OP(1)=0
X(1,1)=15
X(1,2)=15
DO 1 I=3,17
1 X(1,I)=0
CALL RESET
RETURN
END
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
SUBROUTINE ADEXPD (*)
C DATE OF LAST CHANGE - 740717
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(6), X(6,17), OP(6), D(16)
* /MISC/ L, M, FIX, SCI, ERROR, R(21,17), W(17)
C ADD EXPONENT OF D TO THAT OF X(1)
J=10*X(1,16)+X(1,17)
IF (X(1,15).EQ.13) J=-J
IF (D(15).EQ.15) D(15)=0
IF (D(16).EQ.15) D(16)=0
K=10*D(15)+D(16)
IF (D(14).EQ.13) K=-K
J=J+K
IF (J.GE.0) GO TO 1
J=-J
X(1,15)=13
GO TO 2
1 X(1,15)=14
2 X(1,16)=J/10
X(1,17)=J-X(1,16)*10
IF (X(1,16).LT.10) RETURN
ERROR=7
RETURN 1
END
SUBROUTINE ENTRY
C DATE OF LAST CHANGE - 740809
IMPLICIT INTEGER (A-Z)
LOGICAL EEX, JUMP, NEXT
COMMON /STACK/ P(6), X(6,17), OP(6), D(16)
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ CODE, EXPR(50), KEY, OLD
* /MISC/ L, M, FIX, SCI, ERROR, R(21,17), W(17)
CALL SETUP (&10)
DO 1 I=2,16
1 D(I)=15
2 IF (CODE.GT.10) GO TO 3
CALL DIGIT
GO TO 11
3 IF (CODE.NE.11) GO TO 4
CALL DECPT
GO TO 11
4 IF (CODE.NE.12) GO TO 5
CALL ENTEXP
IF (ERROR.NE.0) RETURN
GO TO 11
5 IF (CODE.NE.28) GO TO 6
JUMP=.TRUE.
CALL CORECT
IF (.NOT.JUMP) GO TO 11
JUMP=.FALSE.
RETURN
GO TO 11
6 IF (.NOT.EEX.OR.(CODE.NE.13.AND.CODE.NE.14)) GO TO 7
J=10*D(15)+D(16)
IF (J.NE.0 .AND. J.NE.165) GO TO 7
D(14)=CODE
GO TO 11
7 IF (X(1,2).EQ.15) GO TO 8
IF (D(13).EQ.29) CALL ADEXPD (&10)
GO TO 9
8 X(1,2)=0
9 CALL RESET
NEXT=.TRUE.
10 RETURN
11 CALL CONTRL (1)
GO TO 2
END
SUBROUTINE DIGIT
C DATE OF LAST CHANGE - 740630
IMPLICIT INTEGER (A-Z)
LOGICAL EEX, DP
COMMON /STACK/ P(6), X(6,17), OP(6), D(16)
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ CODE, EXPR(50), KEY, OLD
* /MISC/ L, M, FIX, SCI, ERROR, R(21,17), W(17)
IF (.NOT.EEX) GO TO 1
D(15)=D(16)
D(16)=CODE
RETURN
1 IF (M.GT.14) RETURN
IF (DP) GO TO 2
IF (M.EQ.14) RETURN
2 M=M+1
D(M)=CODE
IF (L.GT.13) RETURN
IF (DP) GO TO 3
IF (L.EQ.1) GO TO 4
CALL EXPON (X(1,15),X(1,16),X(1,17),1)
GO TO 5
3 IF (L.NE.1) GO TO 5
CALL EXPON (X(1,15),X(1,16),X(1,17),-1)
4 IF (CODE.EQ.0) RETURN
5 L=L+1
X(1,L)=CODE
RETURN
END
C
C
C
C
C
C
C
C
C
C
SUBROUTINE EXPON (A,B,C,N)
C DATE OF LAST CHANGE - 740210
C ADD 'N' TO THE EXPONENT 'ABC' (I.E. SIGN, DIGIT, DIGIT)
IMPLICIT INTEGER (A-Z)
IF (B.EQ.15) B=0
IF (C.EQ.15) C=0
K=10*B+C
IF (A.EQ.13) K=-K
K=K+N
IF (K.GE.0) GO TO 1
K=-K
A=13
GO TO 2
1 A=14
2 B=K/10
C=K-10*B
RETURN
END
SUBROUTINE DECPT
C DATE OF LAST CHANGE - 741004
IMPLICIT INTEGER (A-Z)
LOGICAL EEX, DP
COMMON /STACK/ P(6), X(6,17), OP(6), D(16)
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /MISC/ L, M, FIX, SCI, ERROR, R(21,17), W(17)
IF (.NOT.EEX) GO TO 1
EEX=.FALSE.
RETURN
1 IF (DP) RETURN
DP=.TRUE.
IF (M.GT.13) RETURN
M=M+1
D(M)=11
RETURN
END
C
C
C
C
C
C
C
C
C
C
C
C
SUBROUTINE ENTEXP
C DATE OF LAST CHANGE - 740712
IMPLICIT INTEGER (A-Z)
LOGICAL EEX, DP
COMMON /STACK/ P(6), X(6,17), OP(6), D(16)
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /MISC/ L, M, FIX, SCI, ERROR, R(21,17), W(17)
IF (.NOT.EEX) GO TO 1
CALL TESTUP (&2)
IF (D(13).EQ.29) CALL ADEXPD (&2)
OP(1)=50
CALL COLAPS (&2)
CALL ENTRUP
D(1)=15
X(1,1)=14
1 D(13)=29
D(14)=15
D(15)=0
D(16)=0
EEX=.TRUE.
IF (M.GT.1) RETURN
X(1,2)=1
L=2
D(2)=1
D(3)=11
M=3
DP=.TRUE.
2 RETURN
END
SUBROUTINE CORECT
C DATE OF LAST CHANGE - 740925
IMPLICIT INTEGER (A-Z)
LOGICAL EEX, DP, JUMP
COMMON /STACK/ P(6), X(6,17), OP(6), D(16)
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /MISC/ L, M, FIX, SCI, ERROR, R(21,17), W(17)
IF (.NOT.JUMP) GO TO 10
C ** START 1 - ENTRY POINT FROM "ENTRY"
JUMP=.FALSE.
IF (.NOT.EEX) GO TO 2
EEX=.FALSE.
DO 1 I=13,16
1 D(I)=15
RETURN
2 IF (M.GT.2) GO TO 4
IF (M.EQ.1) GO TO 3
IF (X(1,1).EQ.13) GO TO 4
3 CALL CLEARX
JUMP=.TRUE.
RETURN
4 IF (.NOT.DP) GO TO 6
IF (D(M).NE.11) GO TO 5
DP=.FALSE.
GO TO 9
5 IF (L.GT.2) GO TO 7
CALL EXPON (X(1,15),X(1,16),X(1,17),1)
IF (L.EQ.2) GO TO 8
IF (L.EQ.1) GO TO 9
GO TO 7
6 IF (L.EQ.1) GO TO 9
IF (L.EQ.2) GO TO 8
CALL EXPON (X(1,15),X(1,16),X(1,17),-1)
7 X(1,L)=0
L=L-1
GO TO 9
8 X(1,2)=15
L=L-1
9 D(M)=15
M=M-1
RETURN
C ** START 2 - ENTRY POINT FROM "LOOK-UP"
10 IF (OP(1).EQ.0) GO TO 11
IF (OP(1).EQ.1) GO TO 12
IF (OP(1).GT.60) GO TO 12
OP(1)=0
RETURN
11 IF (X(1,2).NE.15 .AND. D(3).NE.15) GO TO 12
CALL CLEARX
RETURN
12 ERROR=1
RETURN
END
SUBROUTINE RECALL
C DATE OF LAST CHANGE - 740614
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(6), X(6,17), OP(6), D(16)
* /INPUTS/ CODE, EXPR(50), KEY, OLD
* /MISC/ L, M, FIX, SCI, ERROR, R(21,17), W(17)
IF (CODE.EQ.25) GO TO 4
C ** START 1 - EXPLICIT REGISTERS (A, PI, LST X, LST Y)
IF (CODE-24) 1, 2, 3
1 REGNO=-3
GO TO 5
2 REGNO=-4
GO TO 6
3 REGNO=CODE-40
GO TO 5
C ** START 2 - "R" REGISTERS
4 CALL REG (REGNO)
IF (ERROR.NE.0) RETURN
5 IF (R(REGNO+5,2).NE.15) GO TO 6
ERROR=5
RETURN
6 CALL SETUP (&10)
IF (X(1,1).EQ.13) GO TO 7
CALL TRANS (REGNO,.FALSE.)
GO TO 9
7 CALL TRANS (REGNO,.FALSE.)
IF (X(1,1).EQ.13) GO TO 8
X(1,1)=13
GO TO 9
8 X(1,1)=14
9 CALL UPDATE
10 RETURN
END
SUBROUTINE STORE
C DATE OF LAST CHANGE - 740715
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT
DIMENSION OPCD(19), A(2,17)
COMMON /STACK/ P(6), X(6,17), OP(6), D(16)
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ CODE, EXPR(50), KEY, OLD
* /MISC/ L, M, FIX, SCI, ERROR, R(21,17), W(17)
DATA OPCD /12*0, 30, 31, 0, 40, 41, 0, 60/
OPCODE=0
1 CALL FINDN (K, REGNO, 2)
IF (K.NE.0) GO TO 6
IF (CODE.NE.25) GO TO 2
CALL REG (REGNO)
IF (ERROR.NE.0) RETURN
GO TO 6
2 IF (CODE.NE.23) GO TO 3
REGNO=-3
NEXT=.FALSE.
GO TO 8
3 IF (CODE.EQ.13 .OR. CODE.EQ.14 .OR. CODE.EQ.16 .OR.
* CODE.EQ.17 .OR. CODE.EQ.19) GO TO 5
4 ERROR=3
RETURN
5 OPCODE=OPCD(CODE)
GO TO 1
6 IF (REGNO.LE.15) GO TO 7
ERROR=4
RETURN
7 IF (REGNO.LT.0 .AND. REGNO.NE.-3) GO TO 4
8 IF (OP(1).EQ.0) OP(1)=1
IF (OPCODE.EQ.0) GO TO 11
K=REGNO+5
DO 9 I=1,17
A(1,I)=X(1,I)
9 A(2,I)=R(K,I)
CALL COMBIN (A, 2, OPCODE, &12)
DO 10 I=1,17
10 R(K,I)=A(1,I)
RETURN
11 CALL TRANS (REGNO,.TRUE.)
12 RETURN
END
SUBROUTINE REG (RN)
C DATE OF LAST CHANGE - 740715
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT
COMMON /STACK/ P(6), X(6,17), OP(6), D(16)
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ CODE, EXPR(50), KEY, OLD
* /MISC/ L, M, FIX, SCI, ERROR, R(21,17), W(17)
IND=0
1 CALL FINDN (K, RN, 2)
IF (K.NE.0) GO TO 5
IF (CODE.NE.25) GO TO 2
IF (IND.EQ.15) GO TO 6
IND=IND+1
GO TO 1
2 NEXT=.FALSE.
IF (CODE.NE.23) GO TO 3
RN=(R(2,2)+0.1*R(2,3))*10**R(2,17)
GO TO 5
3 IF (CODE.NE.22) GO TO 4
RN=16
OP(1)=1
GO TO 5
4 ERROR=3
RETURN
5 IF (RN.LE.16) GO TO 7
6 ERROR=4
RETURN
7 IF (IND.EQ.0) RETURN
RN=RN+5
IF (R(RN,2).EQ.15) GO TO 8
RN=(R(RN,2)+0.1*R(RN,3))*10**R(RN,17)
IND=IND-1
GO TO 5
8 ERROR=5
RETURN
END
SUBROUTINE FINDN (K, RN, START)
C DATE OF LAST CHANGE - 740227
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT
COMMON /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ CODE, EXPR(50), KEY, OLD
GO TO (1, 2, 3), START
1 KMAX=1
GO TO 4
2 KMAX=2
GO TO 4
3 KMAX=3
4 NEXT=.FALSE.
K=0
RN=0
5 CALL CONTRL (2)
IF (CODE.GT.10) GO TO 8
K=K+1
KMAX=KMAX-1
IF (K.GT.1) GO TO 6
RN=CODE
GO TO 7
6 RN=10*RN+CODE
7 IF (KMAX.NE.0) GO TO 5
RETURN
8 NEXT=.TRUE.
RETURN
END
C
C
C
C
C
C
C
C
C
C
SUBROUTINE TRANS (REGNO, STORE)
C DATE OF LAST CHANGE - 740715
IMPLICIT INTEGER (A-Z)
LOGICAL STORE
COMMON /STACK/ P(6), X(6,17), OP(6), D(16)
* /MISC/ L, M, FIX, SCI, ERROR, R(21,17), W(17)
K=REGNO+5
IF (STORE) GO TO 2
DO 1 I=1,17
1 X(1,I)=R(K,I)
RETURN
2 DO 3 I=1,17
3 R(K,I)=X(1,I)
IF (R(K,2).EQ.15) R(K,2)=0
IF (R(K,1).EQ.13 .AND. R(K,2).EQ.0) R(K,1)=15
RETURN
END
SUBROUTINE FIXN
C DATE OF LAST CHANGE - 740616
IMPLICIT INTEGER (A-Z)
LOGICAL FIXFLG
COMMON /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ CODE, EXPR(50), KEY, OLD
* /MISC/ L, M, FIX, SCI, ERROR, R(21,17), W(17)
FIXFLG=.TRUE.
CALL NUMBER (&1)
FIX=CODE
CALL UPDATE
1 RETURN
END
C
C
C
C
C
C
C
C
SUBROUTINE SCIN
C DATE OF LAST CHANGE - 740616
IMPLICIT INTEGER (A-Z)
LOGICAL FIXFLG
COMMON /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ CODE, EXPR(50), KEY, OLD
* /MISC/ L, M, FIX, SCI, ERROR, R(21,17), W(17)
FIXFLG=.FALSE.
CALL NUMBER (&1)
SCI=CODE+1
CALL UPDATE
1 RETURN
END
C
C
C
C
C
C
C
C
SUBROUTINE NUMBER (*)
C DATE OF LAST CHANGE - 740616
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT
COMMON /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ CODE, EXPR(50), KEY, OLD
CALL CONTRL (2)
IF (CODE.LT.11) RETURN
NEXT=.TRUE.
CALL UPDATE
RETURN 1
END